home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / efs / efs-tops-20.el.z / efs-tops-20.el
Encoding:
Text File  |  1998-05-21  |  11.9 KB  |  354 lines
  1. ;; -*-Emacs-Lisp-*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;
  4. ;; File:         efs-tops-20.el
  5. ;; Release:      $efs release: 1.15 $
  6. ;; Version:      #Revision: 1.1 $
  7. ;; RCS:          
  8. ;; Description:  TOPS-20 support for efs
  9. ;; Author:       Sandy Rutherford <sandy@math.ubc.ca, sandy@itp.ethz.ch>
  10. ;; Created:      Fri Oct 23 08:52:00 1992
  11. ;; Modified:     Sun Nov 27 18:43:45 1994 by sandy on gandalf
  12. ;; Language:     Emacs-Lisp
  13. ;;
  14. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  15.  
  16. ;;; This file is part of efs. See efs.el for copyright
  17. ;;; (it's copylefted) and warrranty (there isn't one) information.
  18.  
  19. (require 'efs)
  20. (provide 'efs-tops-20)
  21.  
  22. (defconst efs-tops-20-version
  23.   (concat (substring "$efs release: 1.15 $" 14 -2)
  24.       "/"
  25.       (substring "#Revision: 1.1 $" 11 -2)))
  26.  
  27. ;;;; ------------------------------------------------------------
  28. ;;;; TOPS-20 support
  29. ;;;; ------------------------------------------------------------
  30.  
  31. (efs-defun efs-send-pwd tops-20 (host user &optional xpwd)
  32.   ;; pwd doesn't work for tops-20. Need to get the cwd from a dir listing
  33.   ;; this function returns the cwd in tops-20 syntax
  34.   (let* ((temp (efs-make-tmp-name host nil))
  35.      (cmd (concat "dir * " (cdr temp)))
  36.      dir u-dir full-dir result)
  37.     (unwind-protect
  38.     (if (null (and (car (setq result (efs-raw-send-cmd
  39.                       (efs-get-process host user)
  40.                       cmd
  41.                       "Getting TOPS-20 PWD")))
  42.                (progn
  43.              (condition-case ()
  44.                  (delete-file (car temp)) (error nil))
  45.              (car (setq result
  46.                     (efs-raw-send-cmd
  47.                      (efs-get-process host user)
  48.                      cmd
  49.                      "Trying to get TOPS-20 PWD, again."))))))
  50.         (save-excursion
  51.           (set-buffer (get-buffer-create
  52.                efs-data-buffer-name))
  53.           (erase-buffer)
  54.           (if (or (file-readable-p (car temp))
  55.               (sleep-for efs-retry-time)
  56.               (file-readable-p (car temp)))
  57.             ;; Try again.
  58.           (insert-file-contents (car temp))
  59.         (efs-error host user
  60.                (format
  61.                 "list data file %s not readable" (car temp))))
  62.           ;; get the cwd
  63.           (goto-char (point-min))
  64.           (efs-save-match-data
  65.         (if (looking-at "[^ /:]+:<[^<>/ ]+>")
  66.             (progn
  67.               (setq dir (buffer-substring (match-beginning 0)
  68.                           (match-end 0))
  69.                 u-dir (efs-internal-directory-file-name
  70.                    (efs-fix-path 'tops-20 dir t))
  71.                 full-dir (format efs-path-format-string
  72.                          user host u-dir))
  73.               ;; cache the files too
  74.               (efs-set-files full-dir
  75.                       (efs-parse-listing
  76.                        'tops-20 host user u-dir full-dir))
  77.               (efs-add-to-ls-cache full-dir nil (buffer-string) t))))))
  78.       (efs-del-tmp-name (car temp)))
  79.     (cons dir (nth 1 result))))
  80.  
  81. (efs-defun efs-fix-path tops-20 (path &optional reverse)
  82.   ;; Convert PATH from UNIX-ish to tops-20. If REVERSE given, then
  83.   ;; do just that.
  84.   (efs-save-match-data
  85.     (if reverse
  86.     (if (string-match "^\\([^:]+:\\)?<\\([^>.][^>]*\\)>.*$" path)
  87.         (let ((device (and (match-beginning 1)
  88.                    (substring path (match-beginning 1)
  89.                       (match-end 1))))
  90.           (dir (substring path (match-beginning 2)
  91.                   (match-end 2)))
  92.           (file (substring path (1+ (match-end 2)))))
  93.           (while (string-match "\\." dir)
  94.         (setq dir (concat (substring dir 0 (match-beginning 0))
  95.                   "/"
  96.                   (substring dir (match-end 0)))))
  97.           (if device
  98.           (setq dir (concat "/" device "/" dir)))
  99.           (concat dir file))
  100.       (error "path %s didn't match tops-20 syntax" path))
  101.       (if (string-match "^\\(/[^:/]+:/\\)?\\([^./]+/\\)*\\([^/]*\\)$" path)
  102.       (let ((device (and (match-beginning 1)
  103.                  (substring path 1 (1- (match-end 1)))))
  104.         (dir (and (match-beginning 2)
  105.               (substring path (match-beginning 2)
  106.                      (1- (match-end 2)))))
  107.         (file (substring path (match-beginning 3)
  108.                  (match-end 3))))
  109.         (if dir
  110.         (progn
  111.           (while (string-match "/" dir)
  112.             (setq dir (concat (substring dir 0 (match-beginning 0))
  113.                       "."
  114.                       (substring dir (match-end 0)))))
  115.           (if device
  116.               (concat device "<" dir ">" file)
  117.             (concat "<" dir ">" file)))
  118.           (if device
  119.           (error "%s is invalid relative syntax for tops-20" path)
  120.         file)))
  121.     (error "path %s is invalid syntax for tops-20" path)))))
  122.  
  123. (efs-defun efs-fix-dir-path tops-20 (dir-path)
  124.   ;; Convert a path from UNIX-ish to Tops-20 fir a dir listing.
  125.   (cond ((string-equal "/" dir-path)
  126.      (error "Can't list tops-20 devices"))
  127.     ((string-match "/[^:/]+:/$" dir-path)
  128.      (error "Can't list all root directories on a tops-20 device"))
  129.     ((efs-fix-path 'tops-20 dir-path nil))))
  130.  
  131.  
  132. ;; In tops-20 listings, the filename starts immediatley after the date regexp.
  133.  
  134. (defconst efs-tops-20-date-regexp
  135.   (concat
  136.    " [1-3]?[0-9]-\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct"
  137.    "\\|Nov\\|Dec\\)-[0-9][0-9] [0-9][0-9]:[0-9][0-9]:[0-9][0-9] "))
  138.  
  139.  
  140. (efs-defun efs-parse-listing tops-20
  141.   (host user dir path &optional switches)
  142.   ;; Parse the current buffer which is assumed to be a TOPS-20 directory
  143.   ;; listing, and return a hashtable as the result.
  144.   ;; HOST = remote host name
  145.   ;; USER = user name
  146.   ;; DIR = directory in as a full remote path
  147.   ;; PATH = directory in full efs path syntax
  148.   ;; SWITCHES = ls switches (not relevant here)
  149.   (let ((tbl (efs-make-hashtable))
  150.     file)
  151.     (goto-char (point-min))
  152.     (efs-save-match-data
  153.       (if (looking-at " *[^/:]+:<\\([^/.<>]+\\.\\)+> *$")
  154.       ;; looking at the directory name
  155.       (forward-line 1))
  156.       (while (re-search-forward efs-tops-20-date-regexp nil t)
  157.     (setq file (buffer-substring (point)
  158.                      (progn (end-of-line) (point))))
  159.     (if (string-match "\\.DIRECTORY\\.[0-9]+$" file)
  160.         ;; deal with directories
  161.         (efs-put-hash-entry
  162.          (substring file 0 (match-beginning 0)) '(t) tbl)
  163.       (efs-put-hash-entry file '(nil) tbl)
  164.       ;; sans extension
  165.       (if (string-match "\\.[0-9]+$" file)
  166.           (efs-put-hash-entry
  167.            (substring file 0 (match-beginning 0)) '(nil) tbl)))
  168.     (forward-line 1))
  169.       (efs-put-hash-entry "." '(t) tbl)
  170.       (efs-put-hash-entry ".." '(t) tbl))
  171.     tbl))
  172.  
  173. (efs-defun efs-really-file-p tops-20 (file ent)
  174.   ;; Eliminates the version entries
  175.   (or (car ent) ; file-directory-p
  176.       (efs-save-match-data
  177.     (string-match "\\.[0-9]+$" file))))
  178.  
  179. (efs-defun efs-delete-file-entry tops-20 (path &optional dir-p)
  180.   (let ((ignore-case (memq 'tops-20 efs-case-insensitive-host-types)))
  181.     (if dir-p
  182.     (let ((path (file-name-as-directory path))
  183.           files)
  184.       (efs-del-hash-entry path efs-files-hashtable ignore-case)
  185.       (setq path (directory-file-name path)
  186.         files (efs-get-hash-entry (file-name-directory path)
  187.                            efs-files-hashtable
  188.                            ignore-case))
  189.       (if files
  190.           (efs-del-hash-entry (efs-get-file-part path)
  191.                        files ignore-case)))
  192.       (efs-save-match-data
  193.     (let ((file (efs-get-file-part path)))
  194.       (if (string-match "\\.[0-9]+$" file)
  195.           ;; Only delete explicit versions
  196.           (let ((files (efs-get-hash-entry
  197.                 (file-name-directory path)
  198.                 efs-files-hashtable ignore-case)))
  199.         (if files
  200.             (let ((root (substring file 0
  201.                        (match-beginning 0)))
  202.               (completion-ignore-case ignore-case)
  203.               (len (match-beginning 0)))
  204.               (efs-del-hash-entry file files ignore-case)
  205.               ;; Now we need to check if there are any
  206.               ;; versions left. If not, then delete the
  207.               ;; root entry.
  208.               (or (all-completions
  209.                root files
  210.                (function
  211.                 (lambda (sym)
  212.                   (string-match "\\.[0-9]+$"
  213.                         (symbol-name sym) len))))
  214.               (efs-del-hash-entry root files
  215.                            ignore-case)))))))))
  216.     (efs-del-from-ls-cache path t ignore-case)))
  217.  
  218. (efs-defun efs-add-file-entry tops-20
  219.   (path dir-p size owner &optional modes nlinks mdtm)
  220.   ;; The tops-20 version of this function needs to keep track
  221.   ;; of tops-20's file versions.
  222.   (let ((ignore-case (memq 'tops-20 efs-case-insensitive-host-types))
  223.     (ent (let ((dir-p (null (null dir-p))))
  224.            (if mdtm
  225.            (list dir-p size owner nil nil mdtm)
  226.          (list dir-p size owner)))))
  227.     (if dir-p
  228.     (let* ((path (directory-file-name path))
  229.            (files (efs-get-hash-entry  (file-name-directory path)
  230.                         efs-files-hashtable
  231.                         ignore-case)))
  232.       (if files
  233.           (efs-put-hash-entry (efs-get-file-part path)
  234.                        ent files ignore-case)))
  235.       (let ((files (efs-get-hash-entry
  236.             (file-name-directory path)
  237.             efs-files-hashtable ignore-case)))
  238.     (if files
  239.         (let ((file (efs-get-file-part path)))
  240.           (efs-save-match-data
  241.         (if (string-match "\\.[0-9]+$" file)
  242.             (efs-put-hash-entry
  243.              (substring file 0 (match-beginning 0))
  244.              ent files ignore-case)
  245.           ;; Need to figure out what version of the file
  246.           ;; is being added.
  247.           (let* ((completion-ignore-case ignore-case)
  248.              (len (length file))
  249.              (versions (all-completions
  250.                     file files
  251.                     (function
  252.                      (lambda (sym)
  253.                        (string-match "\\.[0-9]+$"
  254.                              (symbol-name sym) len)))))
  255.              (N (1+ len))
  256.              (max (apply
  257.                    'max
  258.                    (cons 0 (mapcar
  259.                     (function
  260.                      (lambda (x)
  261.                        (string-to-int (substring x N))))
  262.                     versions)))))
  263.             ;; No need to worry about case here.
  264.             (efs-put-hash-entry
  265.              (concat file "." (int-to-string (1+ max))) ent files))))
  266.           (efs-put-hash-entry file ent files ignore-case)))))
  267.     (efs-del-from-ls-cache path t ignore-case)))
  268.  
  269. (efs-defun efs-internal-file-name-as-directory tops-20 (name)
  270.   (efs-save-match-data
  271.     (if (string-match "\\.DIRECTORY\\(\\.[0-9>]\\)?$" name)
  272.     (setq name (substring name 0 (match-beginning 0))))
  273.     (let (file-name-handler-alist)
  274.       (file-name-as-directory name))))
  275.  
  276. ;;; Tree Dired
  277.  
  278. (defconst efs-dired-tops-20-re-dir
  279.   "^[^\n]+\\.DIRECTORY\\(\\.[0-9]+\\)?$")
  280.  
  281. (or (assq 'tops-20 efs-dired-re-dir-alist)
  282.     (setq efs-dired-re-dir-alist
  283.       (cons (cons 'tops-20  efs-dired-tops-20-re-dir)
  284.         efs-dired-re-dir-alist)))
  285.  
  286.  
  287. (efs-defun efs-dired-manual-move-to-filename tops-20
  288.   (&optional raise-error bol eol)
  289.   ;; In dired, move to first char of filename on this line.
  290.   ;; Returns position (point) or nil if no filename on this line.
  291.   ;; This is the Tops-20 version.
  292.   (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point))))
  293.   (let (case-fold-search)
  294.     (if bol
  295.     (goto-char bol)
  296.       (skip-chars-backward "^\n\r"))
  297.     (if (re-search-forward efs-tops-20-date-regexp eol t)
  298.     (point)
  299.       (and raise-error (error "No file on this line")))))
  300.  
  301. (efs-defun efs-dired-manual-move-to-end-of-filename tops-20
  302.   (&optional no-error bol eol)
  303.   ;; Assumes point is at beginning of filename.
  304.   ;; So, it should be called only after (dired-move-to-filename t).
  305.   ;; On failure, signals an error or returns nil.
  306.   ;; This is the Tops-20 version.
  307.   (let ((opoint (point)))
  308.     (and selective-display
  309.      (null no-error)
  310.      (eq (char-after
  311.           (1- (or bol (save-excursion
  312.                 (skip-chars-backward "^\r\n")
  313.                 (point)))))
  314.          ?\r)
  315.      ;; File is hidden or omitted.
  316.      (cond
  317.       ((dired-subdir-hidden-p (dired-current-directory))
  318.        (error
  319.         (substitute-command-keys
  320.          "File line is hidden. Type \\[dired-hide-subdir] to unhide.")))
  321.       ((error
  322.         (substitute-command-keys
  323.          "File line is omitted. Type \\[dired-omit-toggle] to un-omit."
  324.          )))))
  325.     ;; Is this the right character set?
  326.     (skip-chars-forward "-_A-Z0-9$.;")
  327.     (if (or (= opoint (point)) (not (memq (following-char) '(?\n ?\r))))
  328.     (if no-error
  329.           nil
  330.       (error "No file on this line"))
  331.       (point))))
  332.  
  333. (efs-defun efs-internal--file-name-sans-versions tops-20
  334.   (name &optional keep-backup-version)
  335.   (efs-save-match-data
  336.     (if (string-match "\\.[0-9]+$" name)
  337.     (substring name 0 (match-beginning 0))
  338.       name)))
  339.  
  340. (efs-defun efs-dired-insert-headerline tops-20 (dir)
  341.   ;; TOPS-20 inserts a headerline. I would prefer the headerline
  342.   ;; to be in efs format. This version tries to
  343.   ;; be careful, because we can't count on a headerline
  344.   ;; over ftp, and we wouldn't want to delete anything
  345.   ;; important.
  346.   (save-excursion
  347.     (if (looking-at "^  wildcard ")
  348.     (forward-line 1))
  349.     (if (looking-at "^[ \n\t]*[^:/<>]+:<[^<>/]+> *\n")
  350.     (delete-region (point) (match-end 0)))
  351.     (insert "  " (directory-file-name dir) ":\n\n")))
  352.  
  353. ;;; end of efs-tops-20.el
  354.